home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / inc / system.inc < prev    next >
Text File  |  1998-09-21  |  16KB  |  621 lines
  1. {
  2.     $Id: system.inc,v 1.28 1998/08/17 12:24:16 carl Exp $
  3.     This file is part of the Free Pascal Run time library.
  4.     Copyright (c) 1993,97 by the Free Pascal development team
  5.  
  6.     See the file COPYING.FPC, included in this distribution,
  7.     For details about the copyright.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12.  
  13.  **********************************************************************}
  14.  
  15. {****************************************************************************
  16.                                 Local types
  17. ****************************************************************************}
  18.  
  19. {
  20.   TextRec and FileRec are put in a separate file to make it available to other
  21.   units without putting it explicitly in systemh.
  22.   This way we keep TP compatibility, and the TextRec definition is available
  23.   for everyone who needs it.
  24. }
  25. {$i filerec.inc}
  26. {$i textrec.inc}
  27.  
  28. Procedure HandleError (Errno : Longint); forward;
  29.  
  30. type
  31.   FileFunc = Procedure(var t : TextRec);
  32.  
  33. const
  34. { Random / Randomize constants }
  35.   OldRandSeed : Longint = 0;
  36.   InitialSeed : Boolean = TRUE;
  37.   Seed1 : Longint = 0;
  38.   Seed2 : Longint = 0;
  39.   Seed3 : Longint = 0;
  40.  
  41. { For Error Handling.}
  42.   DoError   : Boolean = FALSE;
  43.   ErrorBase : Longint = 0;
  44.  
  45. {****************************************************************************
  46.                     Include processor specific routines
  47. ****************************************************************************}
  48.  
  49. {$IFDEF I386}
  50.   {$IFDEF M68K}
  51.     {$Error Can't determine processor type !}
  52.   {$ENDIF}
  53.   {$I i386.inc}  { Case dependent, don't change }
  54. {$ELSE}
  55.   {$IFDEF M68K}
  56.     {$I m68k.inc}  { Case dependent, don't change }
  57.   {$ELSE}
  58.     {$Error Can't determine processor type !}
  59.   {$ENDIF}
  60. {$ENDIF}
  61.  
  62. {****************************************************************************
  63.                      Routines which have compiler magic
  64. ****************************************************************************}
  65.  
  66. {$I innr.inc}
  67.  
  68. Function  lo(i : Integer) : byte;  [INTERNPROC: In_lo_Word];
  69. Function  lo(w : Word) : byte;     [INTERNPROC: In_lo_Word];
  70. Function  lo(l : Longint) : Word;  [INTERNPROC: In_lo_long];
  71. Function  hi(i : Integer) : byte;  [INTERNPROC: In_hi_Word];
  72. Function  hi(w : Word) : byte;     [INTERNPROC: In_hi_Word];
  73. Function  hi(l : Longint) : Word;  [INTERNPROC: In_hi_long];
  74. {$ifdef VER0_99_5}
  75. Procedure Inc(var i : Cardinal);   [INTERNPROC: In_Inc_DWord];
  76. Procedure Inc(var i : Longint);    [INTERNPROC: In_Inc_DWord];
  77. Procedure Inc(var i : Integer);    [INTERNPROC: In_Inc_Word];
  78. Procedure Inc(var i : Word);       [INTERNPROC: In_Inc_Word];
  79. Procedure Inc(var i : shortint);   [INTERNPROC: In_Inc_byte];
  80. Procedure Inc(var i : byte);       [INTERNPROC: In_Inc_byte];
  81. Procedure Inc(var c : Char);       [INTERNPROC: In_Inc_byte];
  82. Procedure Inc(var p : PChar);      [INTERNPROC: In_Inc_DWord];
  83. Procedure Dec(var i : Cardinal);   [INTERNPROC: In_Dec_DWord];
  84. Procedure Dec(var i : Longint);    [INTERNPROC: In_Dec_DWord];
  85. Procedure Dec(var i : Integer);    [INTERNPROC: In_Dec_Word];
  86. Procedure Dec(var i : Word);       [INTERNPROC: In_Dec_Word];
  87. Procedure Dec(var i : shortint);   [INTERNPROC: In_Dec_byte];
  88. Procedure Dec(var i : byte);       [INTERNPROC: In_Dec_byte];
  89. Procedure Dec(var c : Char);       [INTERNPROC: In_Dec_byte];
  90. Procedure Dec(var p : PChar);      [INTERNPROC: In_Dec_DWord];
  91. {$endif VER0_99_5}
  92.  
  93. Function chr(b : byte) : Char;      [INTERNPROC: In_chr_byte];
  94. Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
  95.  
  96. Procedure Reset(var f : TypedFile);   [INTERNPROC: In_Reset_TypedFile];
  97. Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
  98.  
  99.  
  100. {****************************************************************************
  101.                                 Set Handling
  102. ****************************************************************************}
  103.  
  104. { Include set support which is processor specific}
  105. {$I set.inc}
  106.  
  107. {****************************************************************************
  108.                   Subroutines for String handling
  109. ****************************************************************************}
  110.  
  111. { Needs to be before RTTI handling }
  112.  
  113. {$i sstrings.inc}
  114.  
  115. {$ifdef UseAnsiStrings}
  116.  
  117. Type
  118.    PLongint = ^Longint;
  119.    PByte = ^Byte;
  120.  
  121. {$i astrings.pp}
  122.  
  123. {$else}
  124.  
  125. { Provide dummy procedures needed for rtti}
  126. Procedure decr_ansi_ref (P : pointer);[Alias : 'DECR_ANSI_REF'];
  127.   begin
  128.   end;
  129.  
  130. Procedure incr_ansi_ref (P : pointer);[Alias : 'INCR_ANSI_REF'];
  131.   begin
  132.   end;
  133.  
  134. {$endif}
  135.  
  136.  
  137. {****************************************************************************
  138.                          Run-Time Type Information (RTTI)
  139. ****************************************************************************}
  140.  
  141. {$ifndef VER0_99_5}
  142.   {$i rtti.inc}
  143. {$endif  VER0_99_5}
  144.  
  145. {****************************************************************************
  146.                                Math Routines
  147. ****************************************************************************}
  148.  
  149. {$ifndef RTLLITE}
  150.  
  151. function Hi(b : byte): byte;
  152. begin
  153.    Hi := b shr 4
  154. end;
  155.  
  156. function Lo(b : byte): byte;
  157. begin
  158.    Lo := b and $0f
  159. end;
  160.  
  161. {$ifdef VER0_99_5}
  162.  
  163. Procedure Inc(var i : Cardinal;a: Longint);
  164. Begin
  165.   I:=I+A;
  166. End;
  167.  
  168. Procedure Dec(var i : Cardinal;a: Longint);
  169. Begin
  170.   I:=I-A;
  171. End;
  172.  
  173. Procedure Inc(var i : Longint;a : Longint);
  174. Begin
  175.   i:=i+a;
  176. End;
  177.  
  178. Procedure Dec(var i : Longint;a : Longint);
  179. Begin
  180.   i:=i-a;
  181. End;
  182.  
  183. Procedure Dec(var i : Word;a : Longint);
  184. Begin
  185.   i:=i-a;
  186. End;
  187.  
  188. Procedure Inc(var i : Word;a : Longint);
  189. Begin
  190.   i:=i+a;
  191. End;
  192.  
  193. Procedure Dec(var i : Integer;a : Longint);
  194. Begin
  195.   i:=i-a;
  196. End;
  197.  
  198. Procedure Inc(var i : Integer;a : Longint);
  199. Begin
  200.   i:=i+a;
  201. End;
  202.  
  203. Procedure Dec(var i : byte;a : Longint);
  204. Begin
  205.   i:=i-a;
  206. End;
  207.  
  208. Procedure Inc(var i : byte;a : Longint);
  209. Begin
  210.   i:=i+a;
  211. End;
  212.  
  213. Procedure Dec(var i : shortint;a : Longint);
  214. Begin
  215.   i:=i-a;
  216. End;
  217.  
  218. Procedure Inc(var i : shortint;a : Longint);
  219. Begin
  220.   i:=i+a;
  221. End;
  222.  
  223. Procedure Dec(var c : Char;a : Longint);
  224. Begin
  225.   byte(c):=byte(c)-a;
  226. End;
  227.  
  228. Procedure Inc(var c : Char;a : Longint);
  229. Begin
  230.   Byte(c):=byte(c)+a;
  231. End;
  232.  
  233. Procedure Dec(var p : PChar;a : Longint);
  234. Begin
  235.   longint(p):=longint(p)-a;
  236. End;
  237.  
  238. Procedure Inc(var p : PChar;a : Longint);
  239. Begin
  240.   longint(p):=longint(p)+a;
  241. End;
  242.  
  243. {$endif VER0_99_5}
  244.  
  245. Function swap (X : Word) : Word;
  246. Begin
  247.   swap:=(X and $ff) shl 8 + (X shr 8)
  248. End;
  249.  
  250. Function Swap (X : Integer) : Integer;
  251. Begin
  252.   Swap:=Integer(Swap(Word(X)));
  253. End;
  254.  
  255. Function swap (X : Longint) : Longint;
  256. Begin
  257.   Swap:=(X and $ffff) shl 16 + (X shr 16)
  258. End;
  259.  
  260. Function Swap (X : Cardinal) : Cardinal;
  261. Begin
  262.   Swap:=Swap(Longint(X));
  263. End;
  264.  
  265. {$endif RTLLITE}
  266.  
  267. {****************************************************************************
  268.                           Random function routines
  269.                   
  270.     This implements a very long cycle random number generator by combining
  271.    three independant generators.  The technique was described in the March
  272.    1987 issue of Byte.
  273.    Taken and modified with permission from the PCQ Pascal rtl code.
  274. ****************************************************************************}
  275.  
  276. {$R-}
  277. {$Q-}
  278.  
  279. Procedure UseSeed(seed : Longint);Forward;
  280.  
  281.  
  282. Function Random : Real;
  283. var
  284.     ReturnValue : Real;
  285. begin
  286.     if (InitialSeed) OR ((RandSeed <> OldRandSeed) AND NOT InitialSeed) then
  287.     Begin
  288.        OldRandSeed:=RandSeed;
  289.     { This is a pretty complicated affair                             }
  290.     {  Initially we must call UseSeed when RandSeed is initalized     }
  291.     {  We must also call UseSeed each time RandSeed is reinitialized  }
  292.     {  DO NOT CHANGE THE ORDER OF DECLARATIONS IN THIS BLOCK          }
  293.     {  UNLESS YOU WANT RANDON TO CRASH OF COURSE (CEC)                }
  294.       InitialSeed:=FALSE;
  295.       UseSeed(Randseed);
  296.     end;
  297.     Inc(Seed1);
  298.     Seed1 := (Seed1 * 706) mod 500009;
  299.     INC(Seed2);
  300.     Seed2 := (Seed2 * 774) MOD 600011;
  301.     INC(Seed3);
  302.     Seed3 := (Seed3 * 871) MOD 765241;
  303.     ReturnValue := Seed1/500009.0 +
  304.             Seed2/600011.0 +
  305.            Seed3/765241.0;
  306.     Random := frac(ReturnValue);
  307. end;
  308.  
  309.  
  310. Function Random(l : Longint) : Longint;
  311. begin
  312.     if (InitialSeed) OR ((RandSeed <> OldRandSeed) AND NOT InitialSeed) then
  313.     Begin
  314.        OldRandSeed:=RandSeed;
  315.     { This is a pretty complicated affair                             }
  316.     {  Initially we must call UseSeed when RandSeed is initalized     }
  317.     {  We must also call UseSeed each time RandSeed is reinitialized  }
  318.     {  DO NOT CHANGE THE ORDER OF DECLARATIONS IN THIS BLOCK          }
  319.     {  UNLESS YOU WANT RANDON TO CRASH OF COURSE (CEC)                }
  320.       InitialSeed:=FALSE;
  321.       UseSeed(Randseed);
  322.     end;
  323.     Inc(Seed1);
  324.     Seed1 := (Seed1 * 998) mod 1000003;
  325.     Random := Seed1 mod l;
  326. end;
  327.  
  328.  
  329. Procedure UseSeed(seed : Longint);
  330. begin
  331.     Seed1 := seed mod 1000003;
  332.     Seed2 := (Random(65000) * Random(65000)) mod 600011;
  333.     Seed3 := (Random(65000) * Random(65000)) mod 765241;
  334. end;
  335.  
  336.  
  337. { Include processor specific routines }
  338. {$I math.inc}
  339.  
  340. {****************************************************************************
  341.                             Memory Management
  342. ****************************************************************************}
  343.  
  344. {$ifndef RTLLITE}
  345.  
  346. Function Ptr(sel,off : Longint) : pointer;
  347. Begin
  348.   sel:=0;
  349.   ptr:=pointer(off);
  350. End;
  351.  
  352. Function Addr (Var X) : Pointer;
  353. Begin
  354.   Addr:=@(X);
  355. End;
  356.  
  357. Function CSeg : Word;
  358. Begin
  359.   Cseg:=0;
  360. End;
  361.  
  362. Function DSeg : Word;
  363. Begin
  364.   Dseg:=0;
  365. End;
  366.  
  367. Function SSeg : Word;
  368. Begin
  369.   Sseg:=0;
  370. End;
  371.  
  372. {$endif RTLLITE}
  373.  
  374. {*****************************************************************************
  375.                              Miscellaneous
  376. *****************************************************************************}
  377.  
  378.  
  379. Function IOResult:Word;
  380. Begin
  381.   IOResult:=InOutRes;
  382.   InOutRes:=0;
  383. End;
  384.  
  385.  
  386. procedure fillchar(var x;count : longint;value : char);
  387. begin
  388.   fillchar(x,count,byte(value));
  389. end;
  390.  
  391.  
  392. {*****************************************************************************
  393.                           Init / Exit / ExitProc
  394. *****************************************************************************}
  395.  
  396. Procedure RunError;
  397. Begin
  398.   RunError (0);
  399. End;
  400.  
  401.  
  402. Procedure Halt;
  403. Begin
  404.   Halt(0);
  405. End;
  406.  
  407.  
  408. Procedure dump_stack(bp : Longint);
  409.  
  410.   Procedure dump_frame(addr : Longint);
  411.   Begin
  412.   {To be used by symify}
  413.     Writeln(stderr,'  0x',HexStr(addr,8));
  414. {$ifdef VER0_99_5}
  415.     Flush(stderr);
  416. {$endif VER0_99_5}
  417.   End;
  418.  
  419. var
  420.   i, prevbp : Longint;
  421. Begin
  422.   prevbp:=bp-1;
  423.   i:=0;
  424.   while bp > prevbp Do
  425.    Begin
  426.      dump_frame(get_addr(bp));
  427.      Inc(i);
  428.      If i>max_frame_dump Then
  429.       exit;
  430.      prevbp:=bp;
  431.      bp:=get_next_frame(bp);
  432.    End;
  433. End;
  434.  
  435.  
  436. Procedure Do_exit;[Public,Alias: '__EXIT'];
  437. {
  438.   Don't call this direct, the call is generated by the compiler
  439.   and by the halt procedure.
  440.   NOTICE: (CEC - 14/Aug/1998)
  441.   The order of calling this routine must not be changed, especially
  442.   regarding doerror, doerror should only be set by handlerror
  443.   and runerror and nowhere else, as certain system units require
  444.   exit procedures to clean up, and they rely on this behavior as not
  445.   to call themselves recursively.
  446. }
  447. var
  448.   current_exit : Procedure;
  449. Begin
  450.   while exitProc<>nil Do
  451.    Begin
  452.      InOutRes:=0;
  453.      current_exit:=tProcedure(exitProc);
  454.      exitProc:=nil;
  455.      current_exit();
  456.    End;
  457.   If DoError Then
  458.    Begin
  459.      Writeln('Run time error  ',Errorcode,' at 0x',hexstr(Longint(Erroraddr),8));
  460.      dump_stack(ErrorBase);
  461.    End;
  462. {$ifdef VER0_99_5}
  463.   Flush(stderr);
  464. {$endif VER0_99_5}
  465. End;
  466.  
  467.  
  468. Type
  469.   PExitProcInfo = ^TExitProcInfo;
  470.   TExitProcInfo = Record
  471.     Next     : PExitProcInfo;
  472.     SaveExit : Pointer;
  473.     Proc     : TProcedure;
  474.   End;
  475. const
  476.   ExitProcList: PExitProcInfo = nil;
  477.  
  478. Procedure DoExitProc;
  479. var
  480.   P    : PExitProcInfo;
  481.   Proc : TProcedure;
  482. Begin
  483.   P:=ExitProcList;
  484.   ExitProcList:=P^.Next;
  485.   ExitProc:=P^.SaveExit;
  486.   Proc:=P^.Proc;
  487.   DisPose(P);
  488.   Proc();
  489. End;
  490.  
  491.  
  492. Procedure AddExitProc(Proc: TProcedure);
  493. var
  494.   P : PExitProcInfo;
  495. Begin
  496.   New(P);
  497.   P^.Next:=ExitProcList;
  498.   P^.SaveExit:=ExitProc;
  499.   P^.Proc:=Proc;
  500.   ExitProcList:=P;
  501.   ExitProc:=@DoExitProc;
  502. End;
  503.  
  504. {*****************************************************************************
  505.       Assert() support.
  506. *****************************************************************************}
  507.  
  508. Procedure do_assert (Const Name,Msg : string; LineNo : Longint); [Public,Alias : 'FPC_DO_ASSERT'];
  509. begin
  510.   If msg='' then
  511.     write (stderr,'Assertion failed. ')
  512.   else
  513.     write (stderr,msg);
  514.   writeln (stderr,'(File : ',name,', line ',LineNo,'.');
  515.   flush (stderr);
  516.   HandleError (227);
  517. end;
  518.  
  519.  
  520. {*****************************************************************************
  521.       SetJmp/LongJmp support.
  522. *****************************************************************************}
  523.  
  524. {$i setjump.inc}
  525.  
  526.  
  527. {*****************************************************************************
  528.       Exception support.
  529. *****************************************************************************}
  530.  
  531. { No go, because objpas needed :( (MVC) }
  532. { $i except.inc}
  533.  
  534.  
  535. {
  536.   $Log: system.inc,v $
  537.   Revision 1.28  1998/08/17 12:24:16  carl
  538.     + important comment added
  539.  
  540.   Revision 1.27  1998/08/13 16:22:11  jonas
  541.   * random now returns a value between 0 and max-1 instead of between 0 and max
  542.  
  543.   Revision 1.26  1998/08/11 00:05:26  peter
  544.     * $ifdef ver0_99_5 updates
  545.  
  546.   Revision 1.25  1998/07/30 13:26:18  michael
  547.   + Added support for ErrorProc variable. All internal functions are required
  548.     to call HandleError instead of runerror from now on.
  549.     This is necessary for exception support.
  550.  
  551.   Revision 1.24  1998/07/28 20:37:45  michael
  552.   + added setjmp/longjmp and exception support
  553.  
  554.   Revision 1.23  1998/07/23 19:53:20  michael
  555.   + Adapted assert to Delphi format
  556.  
  557.   Revision 1.22  1998/07/23 13:08:41  michael
  558.   + Implemented DO_ASSERT function.
  559.  
  560.   Revision 1.21  1998/07/15 12:09:35  carl
  561.     * would not compile under FPC v0.99.5
  562.  
  563.   Revision 1.20  1998/07/13 21:19:12  florian
  564.     * some problems with ansi string support fixed
  565.  
  566.   Revision 1.19  1998/07/08 11:56:55  carl
  567.     * randon and Random(l) now work correctly - don't touch it works!
  568.  
  569.   Revision 1.18  1998/07/02 13:01:55  carl
  570.     * hmmm... it is luck (BSS zeroed with GAS) that DoError and ErrorBase work.
  571.       Now they are initilized instead.
  572.  
  573.   Revision 1.17  1998/07/02 12:53:09  carl
  574.     * DOERROR RESOTRED! DON'T TOUCH :)
  575.  
  576.   Revision 1.16  1998/07/02 12:11:50  carl
  577.     * no SINGLE in m68k and other processors!
  578.  
  579.   Revision 1.15  1998/07/02 09:25:05  peter
  580.     * fixed do_error in runtimeerror
  581.  
  582.   Revision 1.14  1998/07/01 15:29:59  peter
  583.     * better readln/writeln
  584.  
  585.   Revision 1.13  1998/06/26 08:21:09  daniel
  586.   - Doerror removed.
  587.  
  588.   Revision 1.12  1998/06/25 14:04:25  peter
  589.     + internal inc/dec
  590.  
  591.   Revision 1.11  1998/06/25 09:44:20  daniel
  592.   + RTLLITE directive to compile minimal RTL.
  593.  
  594.   Revision 1.10  1998/06/15 15:16:26  daniel
  595.   * RTLLITE conditional added to produce smaller RTL
  596.  
  597.   Revision 1.9  1998/06/10 07:46:45  michael
  598.   + Forgot to commit some changes
  599.  
  600.   Revision 1.8  1998/06/08 12:38:24  michael
  601.   Implemented rtti, inserted ansistrings again
  602.  
  603.   Revision 1.7  1998/06/04 23:46:01  peter
  604.     * comp,extended are only i386 added support_comp,support_extended
  605.  
  606.   Revision 1.6  1998/05/20 11:23:09  cvs
  607.   * test commit. Shouldn't be allowed.
  608.  
  609.   Revision 1.5  1998/05/12 10:42:45  peter
  610.     * moved getopts to inc/, all supported OS's need argc,argv exported
  611.     + strpas, strlen are now exported in the systemunit
  612.     * removed logs
  613.     * removed $ifdef ver_above
  614.  
  615.   Revision 1.4  1998/04/16 12:30:47  peter
  616.     + inc(pchar), dec(pchar), incc(pchar,a),dec(pchar,a)
  617.  
  618.   Revision 1.3  1998/04/08 07:53:32  michael
  619.   + Changed Random() function. Moved from system to processor dependent files (from Pedro Gimeno)
  620. }
  621.